unit WND_SrvMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Spin, ScktComp, ShellAPI, Core_Types, AppInface,
  ComCtrls, Grids, ValEdit;

type
  TfrmSrvMain = class(TForm)
    PageControl1: TPageControl;
    tabServer: TTabSheet;
    Label1: TLabel;
    lblTest: TLabel;
    Label2: TLabel;
    sePort: TSpinEdit;
    btnStart: TButton;
    lbxLog: TListBox;
    txtInitDir: TEdit;
    ServerSocket: TServerSocket;
    tabMime: TTabSheet;
    MimeTypes: TValueListEditor;
    btnMimeSave: TButton;
    btnAddExt: TButton;
    btnClear: TButton;
    procedure lblTestMouseEnter(Sender: TObject);
    procedure lblTestMouseLeave(Sender: TObject);
    procedure lblTestClick(Sender: TObject);
    procedure btnStartClick(Sender: TObject);
    procedure ServerSocketClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure lbxLogDrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure btnAddExtClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure btnClearClick(Sender: TObject);
  private
    FileList : TFileArray;
  public
    { Public declarations }
  end;

var
  frmSrvMain: TfrmSrvMain;

implementation

{$R *.dfm}

procedure TfrmSrvMain.lblTestMouseEnter(Sender: TObject);
begin
  lblTest.Font.Color := clNavy;
end;

procedure TfrmSrvMain.lblTestMouseLeave(Sender: TObject);
begin
  lblTest.Font.Color := clBlack;
end;

procedure TfrmSrvMain.lblTestClick(Sender: TObject);
begin
  ShellExecute(Handle, 'open', PChar('http://localhost:' + IntToStr(sePort.Value) + '/'), nil, nil, SW_SHOWNORMAL);
end;

procedure TfrmSrvMain.btnStartClick(Sender: TObject);
begin
  if btnStart.Caption = 'Start' then
  begin
    ServerSocket.Port := sePort.Value;
    ServerSocket.Active := True;
    btnStart.Caption := 'Stop';
    lbxLog.Items.Add('i: Server STARTED');
  end else
  begin
    ServerSocket.Active := False;
    btnStart.Caption := 'Start';
    lbxLog.Items.Add('i: Server STOPPED');
  end;
end;

procedure TfrmSrvMain.ServerSocketClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
  Headers : Array of String;
  Request, GetDir, Ext : String;
  i : Integer;
  f : File of Byte;
  tmpMem : Pointer;
begin
  Request := Socket.ReceiveText;
  while Pos(#13#10, Request) <> 0 do
  begin
    SetLength(Headers, Length(Headers)+1);
    Headers[High(Headers)] := Copy(Request, 1, Pos(#13#10, Request)-1);
    Delete(Request, 1, Pos(#13#10, Request));
  end;

  lbxLog.Items.Add('> [' + Socket.RemoteAddress + '] ' + Headers[0]);

  GetDir := Headers[0];
  Delete(GetDir, 1, Pos(' ', GetDir));
  GetDir := Copy(GetDir, 1, Pos(' ', GetDir)-1);
  GetDir := StringReplace(GetDir, '%20', ' ', [rfReplaceAll]);

  Socket.SendText('HTTP/1.1 200 OK'#13#10);
  lbxLog.Items.Add('< HTTP/1.1 200 OK');
  if (DirectoryExists(txtInitDir.Text + GetDir)) and (not FileExists(txtInitDir.Text + GetDir)) then
  begin
    Socket.SendText(#13#10);
    Socket.SendText('<html><head><title>' + txtInitDir.Text + '</title></head><body><pre>');

    AppFace.UI_ListPath(PChar(txtInitDir.Text + GetDir), '*.*', @FileList);

    for i := 0 to High(FileList.Files) do
    begin
      if FileList.Files[i].Dir then
        Socket.SendText('[<a href="' + FileList.Files[i].Name + '/">' + FileList.Files[i].Name  + '</a>]' + #13#10)
      else
        Socket.SendText('<a href="' + FileList.Files[i].Name + '"><b>' + FileList.Files[i].Name  + '</b></a>' + #13#10)
    end;

    Socket.SendText('</pre></body>');
  end else
  begin
    if FileExists(txtInitDir.Text + GetDir) then
    begin
      Ext := LowerCase(ExtractFileExt(GetDir));
      Delete(Ext, 1, 1);

      if MimeTypes.Values[Ext] <> '' then
      begin
        Socket.SendText('Content-Type: ' + MimeTypes.Values[Ext] + #13#10);
        lbxLog.Items.Add('< Content-Type: ' + MimeTypes.Values[Ext])
      end else
      begin
        Socket.SendText('Content-Type: application/octet-stream'#13#10);
        lbxLog.Items.Add('< Content-Type: application/octet-stream');
      end;

      AssignFile(f, txtInitDir.Text + GetDir);
      Reset(f);

      Socket.SendText('Content-Length: ' + Inttostr(FileSize(f)) + #13#10#13#10);

      GetMem(tmpMem, FileSize(f));
      BlockRead(f, tmpMem^, FileSize(f));
      Socket.SendBuf(tmpMem^, FileSize(f));

      CloseFile(f);
    end else
      Socket.SendText('<h1>404 - Not Found</h1>');
  end;
  Socket.Close;

  lbxLog.ItemIndex := lbxLog.Items.Count-1;
end;

procedure TfrmSrvMain.lbxLogDrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
begin
  with lbxLog.Canvas do
  begin
    FillRect(Rect);
    case lbxLog.Items.Strings[Index][1] of
      '>': Font.Color := clBlue;
      '<': Font.Color := clGreen;
      'i': Font.Color := clMaroon;
    end;
    TextOut(Rect.Left + 2, Rect.Top, lbxLog.Items.Strings[Index]);
  end;
end;

procedure TfrmSrvMain.btnAddExtClick(Sender: TObject);
begin
  MimeTypes.InsertRow(InputBox('Extension', 'Extension like TXT', ''), '', true);
end;

procedure TfrmSrvMain.FormClose(Sender: TObject; var Action: TCloseAction);
var
  p : Pointer;
  i:Integer;
begin
  GetMem(p, 4);
  Integer(p^) := MimeTypes.Strings.Count;
  AppFace.SE_SaveSetting('Plugins/httpsrv/TypeCount', 4, p);

  for i := 0 to MimeTypes.Strings.Count-1 do
  begin
    GetMem(p, Length(MimeTypes.Strings[i])+1);
    PChar(p) := PChar(MimeTypes.Strings[i]);
    AppFace.SE_SaveSetting(PChar('Plugins/httpsrv/mime' + IntToStr(i)), Length(MimeTypes.Strings[i])+1, p);
  end;
end;

procedure TfrmSrvMain.FormCreate(Sender: TObject);
var
  cnt,i:Integer;
  s:String;
begin
  MimeTypes.Strings.Clear;
  cnt := AppFace.SE_GetIntVal('Plugins/httpsrv/TypeCount');

  for i := 0 to cnt-1 do
  begin
    s := AppFace.SE_GetStringVal(PChar('Plugins/httpsrv/mime' + IntToStr(i)));
    MimeTypes.Strings.Add(s);
  end;
end;

procedure TfrmSrvMain.btnClearClick(Sender: TObject);
begin
  lbxLog.Clear;
end;

end.
